home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / tforth21.lha / tile-forth-2.1 / lib / bitsets.f83 < prev    next >
Text File  |  1991-09-14  |  4KB  |  181 lines
  1. \
  2. \  BIT VECTOR REPRESENTED SETS
  3. \
  4. \  Copyright (C) 1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 25 July 1990
  15. \
  16. \  Last updated on: 6 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, macros, blocks
  20. \
  21. \  Description:
  22. \       Forth level definition of bit vector represented sets and
  23. \       common set operations. Each bit vector set may contain at
  24. \       most 32 items as the set is maintained as a stack element.
  25. \       The set operations are very fast in this representation.
  26. \       Most operations are only one forth primitive, e.g., "and", 
  27. \       "or", etc.
  28. \
  29. \  Copying:
  30. \       This program is free software; you can redistribute it and\or modify
  31. \       it under the terms of the GNU General Public License as published by
  32. \       the Free Software Foundation; either version 1, or (at your option)
  33. \       any later version.
  34. \
  35. \       This program is distributed in the hope that it will be useful,
  36. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  37. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  38. \       GNU General Public License for more details.
  39. \
  40. \       You should have received a copy of the GNU General Public License
  41. \       along with this program; see the file COPYING.  If not, write to
  42. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  43.  
  44. .( Loading Bitsets definitions...) cr
  45.  
  46. #include macros.f83
  47. #include blocks.f83
  48.  
  49. vocabulary bitsets ( -- )
  50.  
  51. macros blocks bitsets definitions 
  52.  
  53. : bitset.type ( -- bitset.type item0)  
  54.   create here 0 , 1
  55. does> ( bitset.type -- )
  56.   drop variable
  57. ;
  58.  
  59. : item ( item1 -- item2)  
  60.   create dup , 2*
  61. does> ( item -- item)
  62.   @
  63. ;
  64.  
  65. : bitset.end ( bitset.type item3 -- )  
  66.   drop last swap ! 
  67. ;
  68.  
  69. 0 constant empty-bitset ( -- bitset0)
  70.  
  71. : (>item) ( item bitset.type -- entry)
  72.   dup >r >body @
  73.   begin
  74.     2dup >body @ =
  75.     if swap r> 2drop exit then
  76.     @ r@ over =
  77.   until
  78.   2drop r> drop false
  79. ; private
  80.  
  81. : >item ( item -- entry)
  82.   ' [compile] literal ?compile (>item)
  83. ; immediate
  84.  
  85. : add-bitset ( item bitset1 -- bitset2) 
  86.   or 
  87. ; macro
  88.  
  89. : union-bitset ( bitset1 bitset2 -- bitset3) 
  90.   or 
  91. ; macro
  92.  
  93. : intersection-bitset ( bitset1 bitset2 -- bitset3)
  94.   and
  95. ; macro
  96.  
  97. : remove-bitset ( item bitset1 -- bitset2) 
  98.   swap not and 
  99. ; macro
  100.  
  101. : difference-bitset ( bitset1 bitset2 -- bitset3) 
  102.   not and 
  103. ; macro
  104.  
  105. : size-bitset ( bitset -- num)
  106.   0 swap
  107.   begin
  108.     ?dup
  109.   while
  110.     dup 0<
  111.     if swap 1+ swap then
  112.     2*
  113.   repeat
  114. ;
  115.  
  116. : ?empty-bitset ( bitset -- bool)
  117.   0=
  118. ; macro
  119.  
  120. : ?member-bitset ( item bitset -- bool)
  121.   and boolean
  122. ; macro
  123.  
  124. : { ( -- )
  125.   compiling 0 [compile] [ 
  126. ; immediate
  127.  
  128. : } ( -- bitset)
  129.   empty-bitset
  130.   begin
  131.     swap ?dup
  132.   while
  133.     union-bitset
  134.   repeat
  135.   swap 
  136.   if ] then
  137. ; 
  138.  
  139. : map-bitset ( bitset block[ item -- ] -- )
  140.   >r 1 
  141.   begin
  142.     ?dup
  143.   while
  144.     2dup and
  145.     if r@ rot >r over >r
  146.        call
  147.        2r> swap
  148.     then
  149.     2*
  150.   repeat
  151.   r> 2drop
  152. ;
  153.  
  154. : ?map-bitset ( bitset block[ item -- bool] -- )
  155.   >r 1 
  156.   begin
  157.     ?dup
  158.   while
  159.     2dup and
  160.     if r@ rot >r over >r
  161.        call
  162.        2r> swap rot
  163.        if drop 0 then
  164.     then
  165.     2*
  166.   repeat
  167.   r> 2drop
  168. ;
  169.  
  170. : (.bitset) ( bitset bitset.type -- )
  171.   ." { " swap
  172.   block[ over (>item) .name space ]; map-bitset
  173.   ." } " drop
  174. ;
  175.  
  176. : .bitset ( bitset -- )
  177.   ' [compile] literal ?compile (.bitset)
  178. ; immediate
  179.  
  180. forth only
  181.